home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / RMEMMGT.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  45.2 KB  |  1,429 lines
  1. /*
  2.  * File: rmemmgt.r
  3.  *  Contents: block description arrays, dump routines, garbage collection,
  4.  *    sweep
  5.  */
  6.  
  7. /*
  8.  * Prototype
  9.  */
  10.  
  11. novalue    sweep_stk    Params((struct b_coexpr *ce));
  12.  
  13. #ifdef IconAlloc
  14. /*
  15.  *  If IconAlloc is defined the system allocation routines are not overloaded.
  16.  *  The names are changed so that Icon's allocation routines are independently
  17.  *  used.  This works as long as no other system calls cause the break value
  18.  *  to change.
  19.  */
  20. #define malloc mem_alloc
  21. #define free mem_free
  22. #define realloc mem_realloc
  23. #define calloc mem_calloc
  24. #endif                                  /* IconAlloc */
  25.  
  26. #ifdef CRAY
  27. #include <malloc.h>
  28. #endif                    /* CRAY */
  29.  
  30. word coll_stat = 0;             /* collections in static region */
  31. word coll_str = 0;              /* collections in string region */
  32. word coll_blk = 0;              /* collections in block region */
  33. word coll_tot = 0;              /* total collections */
  34. #ifdef FixedRegions
  35. word alcnum = 0;                /* co-expressions allocated since g.c. */
  36. #endif                                  /* FixedRegions */
  37.  
  38. dptr *quallist;                 /* string qualifier list */
  39. dptr *qualfree;                         /* qualifier list free pointer */
  40. dptr *equallist;                /* end of qualifier list */
  41.  
  42. int qualfail;                   /* flag: qualifier list overflow */
  43.  
  44.  
  45. /*
  46.  * Note: function calls beginning with "MM" are just empty macros
  47.  * unless MemMon is defined.
  48.  */
  49.  
  50. /*
  51.  * Allocated block size table (sizes given in bytes).  A size of -1 is used
  52.  *  for types that have no blocks; a size of 0 indicates that the
  53.  *  second word of the block contains the size; a value greater than
  54.  *  0 is used for types with constant sized blocks.
  55.  */
  56.  
  57. int bsizes[] = {
  58.     -1,                       /* T_Null (0), not block */
  59.     -1,                       /* T_Integer (1), not block */
  60.      0,                       /* T_Lrgint (2), large integer */
  61.      sizeof(struct b_real),   /* T_Real (3), real number */
  62.      sizeof(struct b_cset),   /* T_Cset (4), cset */
  63.      sizeof(struct b_file),   /* T_File (5), file block */
  64.      0,                       /* T_Proc (6), procedure block */
  65.      0,                       /* T_Record (7), record block */
  66.      sizeof(struct b_list),   /* T_List (8), list header block */
  67.      0,                       /* T_Lelem (9), list element block */
  68.      sizeof(struct b_set),    /* T_Set (10), set header block */
  69.      sizeof(struct b_selem),  /* T_Selem (11), set element block */
  70.      sizeof(struct b_table),  /* T_Table (12), table header block */
  71.      sizeof(struct b_telem),  /* T_Telem (13), table element block */
  72.      sizeof(struct b_tvtbl),  /* T_Tvtbl (14), table element trapped variable */
  73.      0,                       /* T_Slots (15), set/table hash block */
  74.      sizeof(struct b_tvsubs), /* T_Tvsubs (16), substring trapped variable */
  75.      0,                       /* T_Refresh (17), refresh block */
  76.     -1,                       /* T_Coexpr (18), co-expression block */
  77.      0,                       /* T_External (19) external block */
  78.      -1,                      /* T_Kywdint (20), integer keyword variable */
  79.      -1,                      /* T_Kywdpos (21), keyword &pos */
  80.      -1,                      /* T_Kywdsubj (22), keyword &subject */
  81.      -1,                      /* T_Tvkywd (23), keyword trapped variable */
  82.     };
  83.  
  84. /*
  85.  * Table of offsets (in bytes) to first descriptor in blocks.  -1 is for
  86.  *  types not allocated, 0 for blocks with no descriptors.
  87.  */
  88. int firstd[] = {
  89.     -1,                       /* T_Null (0), not block */
  90.     -1,                       /* T_Integer (1), not block */
  91.      0,                       /* T_Lrgint (2), large integer */
  92.      0,                       /* T_Real (3), real number */
  93.      0,                       /* T_Cset (4), cset */
  94.      3*WordSize,              /* T_File (5), file block */
  95.  
  96.      7*WordSize,              /* T_Proc (6), procedure block */
  97.  
  98.      4*WordSize,              /* T_Record (7), record block */
  99.      0,                       /* T_List (8), list header block */
  100.      7*WordSize,              /* T_Lelem (9), list element block */
  101.      0,                       /* T_Set (10), set header block */
  102.      3*WordSize,              /* T_Selem (11), set element block */
  103.      (4+HSegs)*WordSize,      /* T_Table (12), table header block */
  104.      3*WordSize,              /* T_Telem (13), table element block */
  105.      3*WordSize,              /* T_Tvtbl (14), table element trapped variable */
  106.      0,                       /* T_Slots (15), set/table hash block */
  107.      3*WordSize,              /* T_Tvsubs (16), substring trapped variable */
  108.  
  109. #if COMPILER
  110.      2*WordSize,              /* T_Refresh (17), refresh block */
  111. #else                /* COMPILER */
  112.      (4+Wsizeof(struct pf_marker))*WordSize, /* T_Refresh (17), refresh block */
  113. #endif                /* COMPILER */
  114.  
  115.     -1,                       /* T_Coexpr (18), co-expression block */
  116.      0,                       /* T_External (19), external block */
  117.      -1,                      /* T_Kywdint (20), integer keyword variable */
  118.      -1,                      /* T_Kywdpos (21), keyword &pos */
  119.      -1,                      /* T_Kywdsubj (22), keyword &subject */
  120.      -1,                      /* T_Tvkywd (23), keyword trapped variable */
  121.     };
  122.  
  123. /*
  124.  * Table of offsets (in bytes) to first pointer in blocks.  -1 is for
  125.  *  types not allocated, 0 for blocks with no pointers.
  126.  */
  127. int firstp[] = {
  128.     -1,                       /* T_Null (0), not block */
  129.     -1,                       /* T_Integer (1), not block */
  130.      0,                       /* T_Lrgint (2), large integer */
  131.      0,                       /* T_Real (3), real number */
  132.      0,                       /* T_Cset (4), cset */
  133.      0,                       /* T_File (5), file block */
  134.      0,                       /* T_Proc (6), procedure block */
  135.      3*WordSize,              /* T_Record (7), record block */
  136.      3*WordSize,              /* T_List (8), list header block */
  137.      2*WordSize,              /* T_Lelem (9), list element block */
  138.      4*WordSize,              /* T_Set (10), set header block */
  139.      1*WordSize,              /* T_Selem (11), set element block */
  140.      4*WordSize,              /* T_Table (12), table header block */
  141.      1*WordSize,              /* T_Telem (13), table element block */
  142.      1*WordSize,              /* T_Tvtbl (14), table element trapped variable */
  143.      2*WordSize,              /* T_Slots (15), set/table hash block */
  144.      0,                       /* T_Tvsubs (16), substring trapped variable */
  145.      0,                       /* T_Refresh (17), refresh block */
  146.     -1,                       /* T_Coexpr (18), co-expression block */
  147.      0,                       /* T_External (19), external block */
  148.      -1,                      /* T_Kywdint (20), integer keyword variable */
  149.      -1,                      /* T_Kywdpos (21), keyword &pos */
  150.      -1,                      /* T_Kywdsubj (22), keyword &subject */
  151.      -1,                      /* T_Tvkywd (23), keyword trapped variable */
  152.     };
  153.  
  154. /*
  155.  * Table of number of pointers in blocks.  -1 is for types not allocated and
  156.  *  types without pointers, 0 for pointers through the end of the block.
  157.  */
  158. int ptrno[] = {
  159.     -1,                       /* T_Null (0), not block */
  160.     -1,                       /* T_Integer (1), not block */
  161.     -1,                       /* T_Lrgint (2), large integer */
  162.     -1,                       /* T_Real (3), real number */
  163.     -1,                       /* T_Cset (4), cset */
  164.     -1,                       /* T_File (5), file block */
  165.     -1,                       /* T_Proc (6), procedure block */
  166.      1,                       /* T_Record (7), record block */
  167.      2,                       /* T_List (8), list header block */
  168.      2,                       /* T_Lelem (9), list element block */
  169.      HSegs,                   /* T_Set (10), set header block */
  170.      1,                       /* T_Selem (11), set element block */
  171.      HSegs,                   /* T_Table (12), table header block */
  172.      1,                       /* T_Telem (13), table element block */
  173.      1,                       /* T_Tvtbl (14), table element trapped variable */
  174.      0,                       /* T_Slots (15), set/table hash block */
  175.     -1,                       /* T_Tvsubs (16), substring trapped variable */
  176.     -1,                       /* T_Refresh (17), refresh block */
  177.     -1,                       /* T_Coexpr (18), co-expression block */
  178.     -1,                       /* T_External (19), external block */
  179.     -1,                       /* T_Kywdint (20), integer keyword variable */
  180.     -1,                       /* T_Kywdpos (21), keyword &pos */
  181.     -1,                       /* T_Kywdsubj (22), keyword &subject */
  182.     -1,                       /* T_Tvkywd (23), keyword trapped variable */
  183.     };
  184.  
  185. /*
  186.  * Table of block names used by debugging functions.
  187.  */
  188. char *blkname[] = {
  189.    "illegal object",                    /* T_Null (0), not block */
  190.    "illegal object",                    /* T_Integer (1), not block */
  191.    "large integer",                     /* T_Largint (2) */
  192.    "real number",                       /* T_Real (3) */
  193.    "cset",                              /* T_Cset (4) */
  194.    "file",                              /* T_File (5) */
  195.    "procedure",                         /* T_Proc (6) */
  196.    "record",                            /* T_Record (7) */
  197.    "list",                              /* T_List (8) */
  198.    "list element",                      /* T_Lelem (9) */
  199.    "set",                               /* T_Set (10) */
  200.    "set elememt",                       /* T_Selem (11) */
  201.    "table",                             /* T_Table (12) */
  202.    "table element",                     /* T_Telem (13) */
  203.    "table element trapped variable",    /* T_Tvtbl (14) */
  204.    "hash block",                        /* T_Slots (15) */
  205.    "substring trapped variable",        /* T_Tvsubs (16) */
  206.    "refresh block",                     /* T_Refresh (17) */
  207.    "co-expression",                     /* T_Coexpr (18) */
  208.    "external block",                    /* T_External (19) */
  209.    "integer keyword variable",          /* T_Kywdint (20) */
  210.    "&pos",                              /* T_Kywdpos (21) */
  211.    "&subject",                          /* T_Kywdsubj (22) */
  212.    "keyword trapped variable",          /* T_Tvkywd (23) */
  213.    };
  214.  
  215. /*
  216.  * Sizes of hash chain segments.
  217.  *  Table size must equal or exceed HSegs.
  218.  */
  219. uword segsize[] = {
  220.    ((uword)HSlots),            /* segment 0 */
  221.    ((uword)HSlots),            /* segment 1 */
  222.    ((uword)HSlots) << 1,        /* segment 2 */
  223.    ((uword)HSlots) << 2,        /* segment 3 */
  224.    ((uword)HSlots) << 3,        /* segment 4 */
  225.    ((uword)HSlots) << 4,        /* segment 5 */
  226.    ((uword)HSlots) << 5,        /* segment 6 */
  227.    ((uword)HSlots) << 6,        /* segment 7 */
  228.    ((uword)HSlots) << 7,        /* segment 8 */
  229.    ((uword)HSlots) << 8,        /* segment 9 */
  230.    ((uword)HSlots) << 9,        /* segment 10 */
  231.    ((uword)HSlots) << 10,        /* segment 11 */
  232.    };
  233.  
  234. #ifdef FixedRegions
  235. #include "../runtime/rmemfix.ri"
  236. #else                                   /* FixedRegions */
  237. #include "../runtime/rmemexp.ri"
  238. #endif                                  /* FixedRegions */
  239.  
  240. /*
  241.  * cofree - collect co-expression blocks.  This is done after
  242.  *  the marking phase of garbage collection and the stacks that are
  243.  *  reachable have pointers to data blocks, rather than T_Coexpr,
  244.  *  in their type field.
  245.  */
  246.  
  247. novalue cofree()
  248.    {
  249.    register struct b_coexpr **ep, *xep;
  250.    register struct astkblk *abp, *xabp;
  251.  
  252.    /*
  253.     * Reset the type for &main.
  254.     */
  255.  
  256.    BlkLoc(k_main)->coexpr.title = T_Coexpr;
  257.  
  258.    /*
  259.     * The co-expression blocks are linked together through their
  260.     *  nextstk fields, with stklist pointing to the head of the list.
  261.     *  The list is traversed and each stack that was not marked
  262.     *  is freed.
  263.     */
  264.    ep = &stklist;
  265.    while (*ep != NULL) {
  266.       if (BlkType(*ep) == T_Coexpr) {
  267.          xep = *ep;
  268.          *ep = (*ep)->nextstk;
  269.          /*
  270.           * Free the astkblks.  There should always be one and it seems that
  271.           *  it's not possible to have more than one, but nonetheless, the
  272.           *  code provides for more than one.
  273.           */
  274.          for (abp = xep->es_actstk; abp; ) {
  275.             xabp = abp;
  276.             abp = abp->astk_nxt;
  277.             free((pointer)xabp);
  278.             }
  279.  
  280. #ifdef CoProcesses
  281.          coswitch(BlkLoc(k_current)->coexpr.cstate, xep->cstate, -1);
  282.          /* terminate coproc for coexpression first */
  283. #endif                    /* CoProcesses */
  284.  
  285.          free((pointer)xep);
  286.          }
  287.       else {
  288.          BlkType(*ep) = T_Coexpr;
  289.          MMStat((char *)(*ep), stksize, E_Coexpr);
  290.          ep = &(*ep)->nextstk;
  291.          }
  292.       }
  293.    /*
  294.     * Also record &main.
  295.     */
  296.  
  297. #if COMPILER
  298.    MMStat((char *)mainhead, (word)sizeof(struct b_coexpr), E_Coexpr);
  299. #else                        /* COMPILER */
  300.    MMStat((char *)mainhead, mstksize, E_Coexpr);
  301. #endif                        /* COMPILER */
  302.  
  303.    }
  304.  
  305.  
  306. #ifdef MultiRegion
  307. /*
  308.  * AlcNewReg - try to malloc a new region and tenure the old one,
  309.  *  backing off if the requested size fails.
  310.  */
  311. struct region *AlcNewReg(nbytes,stdsize)
  312. word nbytes,stdsize;
  313. {
  314.    uword minSize = MinAbrSize;
  315.    struct region *rp;
  316.    if ((uword)nbytes > (uword)MaxBlock) {
  317. #ifdef DebugMultiRegion
  318.       fprintf(stderr,"allocation request %ld greater than Max %u\n",
  319.               nbytes, (unsigned int)MaxBlock);
  320. #endif                    /* DebugMultiRegion */
  321.       return NULL;
  322.    }
  323.    if ((uword)nbytes > minSize) minSize = (uword)nbytes;
  324.    rp = (struct region *)malloc(sizeof(struct region));
  325.    if (rp) {
  326.       rp->size = stdsize;
  327.       if ((rp->size < nbytes) && (nbytes < (unsigned int)MaxBlock))
  328.          rp->size = Min(nbytes+stdsize,(unsigned int)MaxBlock);
  329.  
  330.       do {
  331.          rp->free = rp->base = (char *)AllocReg(rp->size);
  332.          if (rp->free != NULL) {
  333.             rp->end = rp->base + rp->size;
  334. #ifdef DebugMultiRegion
  335.             fprintf(stderr,"allocated %ld for request of %ld\n",
  336.                     rp->size, nbytes);
  337.             fflush(stderr);
  338. #endif                    /* DebugMultiRegion */
  339. #ifdef MemMon
  340.         EVTerm(0, "multiple regions cause monitor exit");
  341. #endif                    /* MemMon */
  342.             return rp;
  343.             }
  344.          else {
  345. #ifdef DebugMultiRegion
  346.             fprintf(stderr,"malloc failed, %ld for request of %ld\n",
  347.                     rp->size, nbytes);
  348.             fflush(stderr);
  349. #endif                    /* DebugMultiRegion */
  350.             }
  351.          rp->size = (rp->size + nbytes)/2 - 1;
  352.          }
  353.       while (rp->size >= minSize);
  354.       free(rp);
  355.       }
  356.    return NULL;
  357. }
  358. #endif                    /* MultiRegion */
  359.  
  360. /*
  361.  * collect - do a garbage collection.
  362.  */
  363. int collect(region,nbytes)
  364. int region;
  365. word nbytes;
  366.    {
  367.    register dptr dp;
  368.    struct b_coexpr *cp;
  369.    int i;
  370.  
  371.  
  372. #ifdef DebugMultiRegion
  373.    fprintf(stderr,"collect(%s,%ld,%d)\n",
  374.            (region==Static)?"Static":((region==Blocks)?"Blocks":"Strings"),
  375.            nbytes,set_err);
  376.    fprintf(stderr,"blkbase %p free %p end %p\n", blkbase, blkfree, blkend);
  377.    fprintf(stderr,"strbase %p free %p end %p\n", strbase, strfree, strend);
  378.    fflush(stderr);
  379. #endif                    /* DebugMultiRegion */
  380.  
  381.  
  382. #ifdef EventMon
  383.    EVVal((word)region,E_Collect);
  384. #endif                    /* EventMon */
  385.    MMBGC(region);
  386.  
  387.    switch (region) {
  388.       case Static:
  389.          statneed = nbytes;
  390.          coll_stat++;
  391.          break;
  392.       case Strings:
  393.          strneed = nbytes;
  394.          coll_str++;
  395.          break;
  396.       case Blocks:  
  397.          blkneed = nbytes;
  398.          coll_blk++;
  399.          break;
  400.       }
  401.    coll_tot++;
  402.  
  403. #ifdef FixedRegions
  404.    alcnum = 0;
  405. #endif                                  /* FixedRegions */
  406.  
  407.    /*
  408.     * Garbage collection cannot be done until initialization is complete.
  409.     */
  410.  
  411. #if !COMPILER
  412.    if (sp == NULL)
  413.       return 0;
  414. #endif                    /* !COMPILER */
  415.  
  416. #if MACINTOSH
  417. #if MPW
  418.    SetCursor(*GetCursor(watchCursor));    /* Set watch cursor */
  419. #endif                    /* MPW */
  420. #endif                    /* MACINTOSH */
  421.  
  422.    /*
  423.     * Sync the values (used by sweep) in the coexpr block for ¤t
  424.     *  with the current values.
  425.     */
  426.    cp = (struct b_coexpr *)BlkLoc(k_current);
  427.    cp->es_tend = tend;
  428.  
  429. #if !COMPILER
  430.    cp->es_pfp = pfp;
  431.    cp->es_gfp = gfp;
  432.    cp->es_efp = efp;
  433.    cp->es_sp = sp;
  434. #endif                    /* !COMPILER */
  435.  
  436.    /*
  437.     * Reset qualifier list.
  438.     */
  439.  
  440. #ifndef FixedRegions
  441.    quallist = (dptr *)blkfree;
  442. #endif                                  /* FixedRegions */
  443.  
  444.    qualfree = quallist;
  445.    qualfail = 0;
  446.  
  447.    /*
  448.     * Mark the stacks for &main and the current co-expression.
  449.     */
  450.    markblock(&k_main);
  451.    markblock(&k_current);
  452.    /*
  453.     * Mark &subject and the cached s2 and s3 strings for map.
  454.     */
  455.    postqual(&k_subject);
  456.    if (Qual(maps2))                     /*  caution: the cached arguments of */
  457.       postqual(&maps2);                 /*  map may not be strings. */
  458.    else if (Pointer(maps2))
  459.       markblock(&maps2);
  460.    if (Qual(maps3))
  461.       postqual(&maps3);
  462.    else if (Pointer(maps3))
  463.       markblock(&maps3);
  464.  
  465.  
  466.    /*
  467.     * Mark the globals and the statics.
  468.     */
  469.  
  470.    for (i = 0; i < n_globals; ++i)
  471.       if (Qual(globals[i]))
  472.          postqual(&globals[i]);
  473.       else if (Pointer(globals[i]))
  474.          markblock(&globals[i]);
  475.  
  476.    for (i = 0; i < n_statics; ++i)
  477.       if (Qual(statics[i]))
  478.          postqual(&statics[i]);
  479.       else if (Pointer(statics[i]))
  480.          markblock(&statics[i]);
  481.  
  482.  
  483.    reclaim(region);
  484.  
  485. #ifdef MultiRegion
  486.    /*
  487.     * Turn off all the marks in all the block regions everywhere
  488.     */
  489.    { struct region *br;
  490.    for (br = curblock->Gnext; br; br = br->Gnext) {
  491.       char *source = br->base, *free = br->free;
  492.       uword NoMark = ~F_Mark;
  493.       while (source < free) {
  494.      BlkType(source) &= NoMark;
  495.          source += BlkSize(source);
  496.          }
  497.       }
  498.    for (br = curblock->Gprev; br; br = br->Gprev) {
  499.       char *source = br->base, *free = br->free;
  500.       uword NoMark = ~F_Mark;
  501.       while (source < free) {
  502.      BlkType(source) &= NoMark;
  503.          source += BlkSize(source);
  504.          }
  505.       }
  506.    }
  507. #endif                    /* MultiRegion */
  508.  
  509.    MMEGC();
  510.  
  511. #ifdef EventMon
  512. #endif                    /* EventMon */
  513.  
  514. #ifndef FixedRegions
  515.    if (qualfail && (region == Strings || statneed) &&
  516.       DiffPtrs((char *)quallist,blkfree) > Sqlinc) {
  517.       /*
  518.        * The string region could not be collected, but it looks like it
  519.        *  needs to be. Collecting the block region gave more room for
  520.        *  the qualifier list, so try again.
  521.        */
  522.        return collect(region,nbytes);
  523.        }
  524. #endif                          /* FixedRegions */
  525.  
  526.    switch (region) {
  527.       case Static:
  528.          /*
  529.           * Failure to get enough storage results in malloc simply returning
  530.           *  NULL, the caller must determine the error message.
  531.           */
  532.          statneed = 0;
  533.          break;
  534.       case Strings:
  535.          strneed = 0;
  536.          if (nbytes > (uword)DiffPtrs(strend,strfree)) {
  537.  
  538. #ifdef FixedRegions
  539. #ifdef MultiRegion
  540.         /*
  541.          * Try to malloc a new string region and tenure old strings.
  542.          */
  543.         struct region *rp = AlcNewReg(nbytes,(uword)MaxStrSpace);
  544.         if (rp) {
  545.            rp->next = curstring;
  546.            rp->prev = NULL;
  547.            curstring->prev = rp;
  548.            rp->Gnext = curstring;
  549.            rp->Gprev = curstring->Gprev;
  550.            if (curstring->Gprev) curstring->Gprev->Gnext = rp;
  551.            curstring->Gprev = rp;
  552.            curstring = rp;
  553.            return 1;
  554.            }
  555. #endif                    /* MultiRegion */
  556.             if (qualfail)
  557.                ReturnErrNum(304, 0);
  558. #endif                                  /* FixedRegions */
  559.  
  560.             ReturnErrNum(306, 0);
  561.             }
  562.          break;
  563.       case Blocks:
  564.          blkneed = 0;
  565.          if (nbytes > (uword)DiffPtrs(blkend,blkfree)) {
  566. #ifdef MultiRegion
  567.         /*
  568.          * Try to malloc a new block region and tenure old blocks.
  569.          */
  570.         struct region *rp = AlcNewReg(nbytes,(uword)MaxAbrSize);
  571.         if (rp) {
  572.            rp->next = curblock;
  573.            rp->prev = NULL;
  574.            curblock->prev = rp;
  575.            rp->Gnext = curblock;
  576.            rp->Gprev = curblock->Gprev;
  577.            if (curblock->Gprev) curblock->Gprev->Gnext = rp;
  578.            curblock->Gprev = rp;
  579.            curblock = rp;
  580.            return 1;
  581.            }
  582. #endif                    /* MultiRegion */
  583.             ReturnErrNum(307, 0);
  584.         }
  585.          break;
  586.       }
  587.     return 1;
  588.    }
  589.  
  590. /*
  591.  * markblock - mark each accessible block in the block region and build
  592.  *  back-list of descriptors pointing to that block. (Phase I of garbage
  593.  *  collection.)
  594.  */
  595. novalue markblock(dp)
  596. dptr dp;
  597.    {
  598.    register dptr dp1;
  599.    register char *block, *endblock;
  600.    word type, fdesc;
  601.    int numptr;
  602.    register union block **ptr, **lastptr;
  603.  
  604.    if (Var(*dp)) {
  605.        if (dp->dword & F_Typecode) {
  606.           switch (Type(*dp)) {
  607.              case T_Kywdint:
  608.              case T_Kywdpos:
  609.              case T_Kywdsubj:
  610.                 /*
  611.                  * The descriptor points to a keyword, not a block.
  612.                  */
  613.                 return;
  614.              }
  615.           }
  616.        else if (Offset(*dp) == 0) {
  617.           /*
  618.            * The descriptor is a simple variable not residing in a block.
  619.            */
  620.           return;
  621.           }
  622.       }
  623.  
  624.    /*
  625.     * Get the block to which dp points.
  626.     */
  627.    block = (char *)BlkLoc(*dp);
  628.  
  629.    if (InRange(blkbase,block,blkfree)) {
  630.       type = BlkType(block);
  631.       if ((uword)type <= MaxType) {
  632.  
  633.          /*
  634.           * The type is valid, which indicates that this block has not
  635.           *  been marked.  Point endblock to the byte past the end
  636.           *  of the block.
  637.           */
  638.          endblock = block + BlkSize(block);
  639.          MMMark(block,(int)type);
  640.          }
  641.  
  642.       /*
  643.        * Add dp to the back chain for the block and point the
  644.        *  block (via the type field) to dp.vword.
  645.        */
  646.       BlkLoc(*dp) = (union block *)type;
  647.       BlkType(block) = (uword)&BlkLoc(*dp);
  648.  
  649.       if ((uword)type <= MaxType) {
  650.          /*
  651.           * The block was not marked; process pointers and descriptors
  652.           *  within the block.
  653.           */
  654.          if ((fdesc = firstp[type]) > 0) {
  655.             /*
  656.              * The block contains pointers; mark each pointer.
  657.              */
  658.             ptr = (union block **)(block + fdesc);
  659.         numptr = ptrno[type];
  660.         if (numptr > 0)
  661.            lastptr = ptr + numptr;
  662.         else
  663.            lastptr = (union block **)endblock;
  664.         for (; ptr < lastptr; ptr++)
  665.            if (*ptr != NULL)
  666.                   markptr(ptr);
  667.         }
  668.          if ((fdesc = firstd[type]) > 0)
  669.             /*
  670.              * The block contains descriptors; mark each descriptor.
  671.              */
  672.             for (dp1 = (dptr)(block + fdesc);
  673.                  (char *)dp1 < endblock; dp1++) {
  674.                if (Qual(*dp1))
  675.                   postqual(dp1);
  676.                else if (Pointer(*dp1))
  677.                   markblock(dp1);
  678.                }
  679.          }
  680.       }
  681.  
  682.    else if (dp->dword == D_Coexpr) {
  683.       if ((unsigned int)BlkType(block) <= MaxType) {
  684.          struct b_coexpr *cp;
  685.          struct astkblk *abp;
  686.          int i;
  687.          struct descrip adesc;
  688.  
  689.          /*
  690.           * dp points to a co-expression block that has not been
  691.           *  marked.  Point the block to dp.  Sweep the interpreter
  692.           *  stack in the block.  Then mark the block for the
  693.           *  activating co-expression and the refresh block.
  694.           */
  695.          BlkType(block) = (uword)dp;
  696.          sweep((struct b_coexpr *)block);
  697.  
  698.  
  699. #ifdef Coexpr
  700.          /*
  701.           * Mark the activators of this co-expression.   The activators are
  702.           *  stored as a list of addresses, but markblock requires the address
  703.           *  of a descriptor.  To accommodate markblock, the dummy descriptor
  704.           *  adesc is filled in with each activator address in turn and then
  705.           *  marked.  Since co-expressions and the descriptors that reference
  706.           *  them don't participate in the back-chaining scheme, it's ok to
  707.           *  reuse the descriptor in this manner.
  708.           */
  709.          cp = (struct b_coexpr *)block;
  710.          adesc.dword = D_Coexpr;
  711.          for (abp = cp->es_actstk; abp != NULL; abp = abp->astk_nxt) {
  712.             for (i = 1; i <= abp->nactivators; i++) {
  713.                BlkLoc(adesc) = (union block *)abp->arec[i-1].activator;
  714.                markblock(&adesc);
  715.                }
  716.             }
  717.          if(BlkLoc(cp->freshblk) != NULL)
  718.             markblock(&((struct b_coexpr *)block)->freshblk);
  719. #endif                                  /* Coexpr */
  720.          }
  721.       }
  722.  
  723. #ifdef MultiRegion
  724.    else {
  725.       struct region *rp;
  726.  
  727.       /*
  728.        * Look for this block in other allocated block regions.
  729.        */
  730.       for (rp = curblock->Gnext; rp; rp = rp->Gnext)
  731.      if (InRange(rp->base,block,rp->free)) break;
  732.  
  733.       if (rp == NULL)
  734.          for (rp = curblock->Gprev; rp; rp = rp->Gprev)
  735.             if (InRange(rp->base,block,rp->free)) break;
  736.  
  737.       /*
  738.        * If this block is not in a block region, its something else
  739.        *  like a procedure block.
  740.        */
  741.       if (rp == NULL)
  742.          return;
  743.  
  744.       /*
  745.        * Get this block's type field; return if it is marked
  746.        */
  747.       type = BlkType(block);
  748.       if ((uword)type > MaxType)
  749.          return;
  750.  
  751.       /*
  752.        * this is an unmarked block outside the (collecting) block region;
  753.        * process pointers and descriptors within the block.
  754.        *
  755.        * The type is valid, which indicates that this block has not
  756.        *  been marked.  Point endblock to the byte past the end
  757.        *  of the block.
  758.        */
  759.       endblock = block + BlkSize(block);
  760.       MMMark(block,(int)type);
  761.  
  762.       BlkType(block) |= F_Mark;            /* mark the block */
  763.  
  764.       if ((fdesc = firstp[type]) > 0) {
  765.          /*
  766.           * The block contains pointers; mark each pointer.
  767.           */
  768.          ptr = (union block **)(block + fdesc);
  769.      numptr = ptrno[type];
  770.      if (numptr > 0)
  771.         lastptr = ptr + numptr;
  772.      else
  773.         lastptr = (union block **)endblock;
  774.      for (; ptr < lastptr; ptr++)
  775.         if (*ptr != NULL)
  776.                markptr(ptr);
  777.      }
  778.       if ((fdesc = firstd[type]) > 0)
  779.          /*
  780.           * The block contains descriptors; mark each descriptor.
  781.           */
  782.          for (dp1 = (dptr)(block + fdesc);
  783.               (char *)dp1 < endblock; dp1++) {
  784.             if (Qual(*dp1))
  785.                postqual(dp1);
  786.             else if (Pointer(*dp1))
  787.                markblock(dp1);
  788.             }
  789.       }
  790. #endif                    /* MultiRegion */
  791.    }
  792.  
  793. /*
  794.  * markptr - just like mark block except the object pointing at the block
  795.  *  is just a block pointer, not a descriptor.
  796.  */
  797.  
  798. novalue markptr(ptr)
  799. union block **ptr;
  800.    {
  801.    register dptr dp;
  802.    register char *block, *endblock;
  803.    word type, fdesc;
  804.    int numptr;
  805.    register union block **ptr1, **lastptr;
  806.  
  807.    /*
  808.     * Get the block to which ptr points.
  809.     */
  810.    block = (char *)*ptr;
  811.    if (InRange(blkbase,block,blkfree)) {
  812.       type = BlkType(block);
  813.       if ((uword)type <= MaxType) {
  814.          /*
  815.           * The type is valid, which indicates that this block has not
  816.           *  been marked.  Point endblock to the byte past the end
  817.           *  of the block.
  818.           */
  819.          endblock = block + BlkSize(block);
  820.          MMMark(block,(int)type);
  821.          }
  822.  
  823.       /*
  824.        * Add ptr to the back chain for the block and point the
  825.        *  block (via the type field) to ptr.
  826.        */
  827.       *ptr = (union block *)type;
  828.       BlkType(block) = (uword)ptr;
  829.  
  830.       if ((uword)type <= MaxType) {
  831.          /*
  832.           * The block was not marked; process pointers and descriptors
  833.           *  within the block.
  834.           */
  835.          if ((fdesc = firstp[type]) > 0) {
  836.             /*
  837.              * The block contains pointers; mark each pointer.
  838.              */
  839.             ptr1 = (union block **)(block + fdesc);
  840.             numptr = ptrno[type];
  841.             if (numptr > 0)
  842.                lastptr = ptr1 + numptr;
  843.             else
  844.                lastptr = (union block **)endblock;
  845.             for (; ptr1 < lastptr; ptr1++)
  846.                if (*ptr1 != NULL)
  847.                   markptr(ptr1);
  848.             }
  849.          if ((fdesc = firstd[type]) > 0)
  850.             /*
  851.              * The block contains descriptors; mark each descriptor.
  852.              */
  853.             for (dp = (dptr)(block + fdesc);
  854.                  (char *)dp < endblock; dp++) {
  855.                if (Qual(*dp))
  856.                   postqual(dp);
  857.                else if (Pointer(*dp))
  858.                   markblock(dp);
  859.                }
  860.          }
  861.       }
  862. #ifdef MultiRegion
  863.    else {
  864.       struct region *rp;
  865.  
  866.       /*
  867.        * Look for this block in other allocated block regions.
  868.        */
  869.       for (rp = curblock->Gnext;rp;rp = rp->Gnext)
  870.      if (InRange(rp->base,block,rp->free)) break;
  871.  
  872.       if (rp == NULL)
  873.          for (rp = curblock->Gprev;rp;rp = rp->Gprev)
  874.             if (InRange(rp->base,block,rp->free)) break;
  875.  
  876.       /*
  877.        * If this block is not in a block region, its something else
  878.        *  like a procedure block.
  879.        */
  880.       if (rp == NULL)
  881.          return;
  882.  
  883.       /*
  884.        * Get this block's type field; return if it is marked
  885.        */
  886.       type = BlkType(block);
  887.       if ((uword)type > MaxType)
  888.          return;
  889.  
  890.       /*
  891.        * this is an unmarked block outside the (collecting) block region;
  892.        * process pointers and descriptors within the block.
  893.        *
  894.        * The type is valid, which indicates that this block has not
  895.        *  been marked.  Point endblock to the byte past the end
  896.        *  of the block.
  897.        */
  898.       endblock = block + BlkSize(block);
  899.       MMMark(block,(int)type);
  900.  
  901.       BlkType(block) |= F_Mark;            /* mark the block */
  902.  
  903.       if ((fdesc = firstp[type]) > 0) {
  904.          /*
  905.           * The block contains pointers; mark each pointer.
  906.           */
  907.          ptr1 = (union block **)(block + fdesc);
  908.          numptr = ptrno[type];
  909.          if (numptr > 0)
  910.         lastptr = ptr1 + numptr;
  911.      else
  912.         lastptr = (union block **)endblock;
  913.      for (; ptr1 < lastptr; ptr1++)
  914.         if (*ptr1 != NULL)
  915.                markptr(ptr1);
  916.      }
  917.       if ((fdesc = firstd[type]) > 0)
  918.          /*
  919.           * The block contains descriptors; mark each descriptor.
  920.           */
  921.          for (dp = (dptr)(block + fdesc);
  922.               (char *)dp < endblock; dp++) {
  923.             if (Qual(*dp))
  924.                postqual(dp);
  925.             else if (Pointer(*dp))
  926.                markblock(dp);
  927.             }
  928.          }
  929. #endif                    /* MultiRegion */
  930.    }
  931.  
  932. /*
  933.  * adjust - adjust pointers into the block region, beginning with block oblk
  934.  *  and basing the "new" block region at nblk.  (Phase II of garbage
  935.  *  collection.)
  936.  */
  937.  
  938. novalue adjust(source,dest)
  939. char *source, *dest;
  940.    {
  941.    register union block **nxtptr, **tptr;
  942.  
  943.    /*
  944.     * Loop through to the end of allocated block region, moving source
  945.     *  to each block in turn and using the size of a block to find the
  946.     *  next block.
  947.     */
  948.    while (source < blkfree) {
  949.       if ((uword)(nxtptr = (union block **)BlkType(source)) > MaxType) {
  950.  
  951.          /*
  952.           * The type field of source is a back pointer.  Traverse the
  953.           *  chain of back pointers, changing each block location from
  954.           *  source to dest.
  955.           */
  956.          while ((uword)nxtptr > MaxType) {
  957.             tptr = nxtptr;
  958.             nxtptr = (union block **) *nxtptr;
  959.             *tptr = (union block *)dest;
  960.             }
  961.          BlkType(source) = (uword)nxtptr | F_Mark;
  962.          dest += BlkSize(source);
  963.          }
  964.       source += BlkSize(source);
  965.       }
  966.    }
  967.  
  968. /*
  969.  * compact - compact good blocks in the block region. (Phase III of garbage
  970.  *  collection.)
  971.  */
  972.  
  973. novalue compact(source)
  974. char *source;
  975.    {
  976.    register char *dest;
  977.    register word size;
  978.  
  979.    /*
  980.     * Start dest at source.
  981.     */
  982.    dest = source;
  983.  
  984.    /*
  985.     * Loop through to end of allocated block space, moving source
  986.     *  to each block in turn, using the size of a block to find the next
  987.     *  block.  If a block has been marked, it is copied to the
  988.     *  location pointed to by dest and dest is pointed past the end
  989.     *  of the block, which is the location to place the next saved
  990.     *  block.  Marks are removed from the saved blocks.
  991.     */
  992.    while (source < blkfree) {
  993.       size = BlkSize(source);
  994.       if (BlkType(source) & F_Mark) {
  995.          BlkType(source) &= ~F_Mark;
  996.          if (source != dest)
  997.             mvc((uword)size,source,dest);
  998.          dest += size;
  999.          }
  1000.       source += size;
  1001.       }
  1002.  
  1003.    /*
  1004.     * dest is the location of the next free block.  Now that compaction
  1005.     *  is complete, point blkfree to that location.
  1006.     */
  1007.    blkfree = dest;
  1008.    }
  1009.  
  1010. /*
  1011.  * postqual - mark a string qualifier.  Strings outside the string space
  1012.  *  are ignored.
  1013.  */
  1014.  
  1015. novalue postqual(dp)
  1016. dptr dp;
  1017.    {
  1018.    char *newend;
  1019.  
  1020. #ifdef CRAY
  1021.    if (strbase <= StrLoc(*dp) && StrLoc(*dp) < (strfree + 1)) {
  1022. #else                    /* CRAY */
  1023.    if (InRange(strbase,StrLoc(*dp),strfree + 1)) { 
  1024. #endif                    /* CRAY */
  1025.  
  1026.       /*
  1027.        * The string is in the string space.  Add it to the string qualifier
  1028.        *  list, but before adding it, expand the string qualifier list if
  1029.        *  necessary.
  1030.        */
  1031.       if (qualfree >= equallist) {
  1032.  
  1033. #ifdef FixedRegions
  1034.          qualfail = 1;
  1035.          return;
  1036. #else                                   /* FixedRegions */
  1037.  
  1038.          newend = (char *)equallist + Sqlinc;
  1039.          /*
  1040.           * Make sure region has not changed and that it can be expanded.
  1041.           */
  1042.          if (currend != (char *)sbrk((word)0) || (int)brk((char *)newend) == -1) {
  1043.             qualfail = 1;
  1044.             return;
  1045.             }
  1046.          equallist = (dptr *)newend;
  1047.          currend = (char *)sbrk((word)0);
  1048.  
  1049. #ifdef QuallistExp
  1050.          fprintf(stderr,"size of quallist = %ld\n",
  1051.             (long)DiffPtrs((char *)equallist,(char *)quallist));
  1052.          fflush(stderr);
  1053. #endif                                  /* QuallistExp */
  1054. #endif                                  /* FixedRegions */
  1055.  
  1056.          }
  1057.       *qualfree++ = dp;
  1058.       }
  1059.    }
  1060.  
  1061.             /* #%#% check against compiler version */
  1062. /*
  1063.  * scollect - collect the string space.  quallist is a list of pointers to
  1064.  *  descriptors for all the reachable strings in the string space.  For
  1065.  *  ease of description, it is referred to as if it were composed of
  1066.  *  descriptors rather than pointers to them.
  1067.  */
  1068.  
  1069. novalue scollect(extra)
  1070. word extra;
  1071.    {
  1072.    register char *source, *dest;
  1073.    register dptr *qptr;
  1074.    char *cend;
  1075.  
  1076.    if (qualfree <= quallist) {
  1077.       /*
  1078.        * There are no accessible strings.  Thus, there are none to
  1079.        *  collect and the whole string space is free.
  1080.        */
  1081.       strfree = strbase;
  1082.       return;
  1083.       }
  1084.    /*
  1085.     * Sort the pointers on quallist in ascending order of string
  1086.     *  locations.
  1087.     */
  1088.    qsort((char *)quallist, (int)(DiffPtrs((char *)qualfree,(char *)quallist)) /
  1089.      sizeof(dptr *), sizeof(dptr), (int (*)())qlcmp);
  1090.    /*
  1091.     * The string qualifiers are now ordered by starting location.
  1092.     */
  1093.    dest = strbase;
  1094.    source = cend = StrLoc(**quallist);
  1095.  
  1096.    /*
  1097.     * Loop through qualifiers for accessible strings.
  1098.     */
  1099.    for (qptr = quallist; qptr < qualfree; qptr++) {
  1100.       if (StrLoc(**qptr) > cend) {
  1101.  
  1102.          /*
  1103.           * qptr points to a qualifier for a string in the next clump.
  1104.           *  The last clump is moved, and source and cend are set for
  1105.           *  the next clump.
  1106.           */
  1107.          MMSMark(source,DiffPtrs(cend,source));
  1108.          while (source < cend)
  1109.             *dest++ = *source++;
  1110.          source = cend = StrLoc(**qptr);
  1111.          }
  1112.       if ((StrLoc(**qptr) + StrLen(**qptr)) > cend)
  1113.          /*
  1114.           * qptr is a qualifier for a string in this clump; extend
  1115.           *  the clump.
  1116.           */
  1117.          cend = StrLoc(**qptr) + StrLen(**qptr);
  1118.       /*
  1119.        * Relocate the string qualifier.
  1120.        */
  1121.       StrLoc(**qptr) = StrLoc(**qptr) + DiffPtrs(dest,source) + (uword)extra;
  1122.       }
  1123.  
  1124.    /*
  1125.     * Move the last clump.
  1126.     */
  1127.    MMSMark(source,DiffPtrs(cend,source));
  1128.    while (source < cend)
  1129.       *dest++ = *source++;
  1130.    strfree = dest;
  1131.    }
  1132.  
  1133. /*
  1134.  * qlcmp - compare the location fields of two string qualifiers for qsort.
  1135.  */
  1136.  
  1137. int qlcmp(q1,q2)
  1138. dptr *q1, *q2;
  1139.    {
  1140.  
  1141. #if IntBits == 16
  1142.    long l;
  1143.    l = (long)(DiffPtrs(StrLoc(**q1),StrLoc(**q2)));
  1144.    if (l < 0)
  1145.       return -1;
  1146.    else if (l > 0)
  1147.       return 1;
  1148.    else
  1149.       return 0;
  1150. #else                                   /* IntBits = 16 */
  1151.    return (int)(DiffPtrs(StrLoc(**q1),StrLoc(**q2)));
  1152. #endif                                  /* IntBits == 16 */
  1153.  
  1154.    }
  1155.  
  1156. /*
  1157.  * mvc - move n bytes from src to dest
  1158.  *
  1159.  *      The algorithm is to copy the data (using memcopy) in the largest
  1160.  * chunks possible, which is the size of area of the source data not in
  1161.  * the destination area (ie non-overlapped area).  (Chunks are expected to
  1162.  * be fairly large.)
  1163.  */
  1164.  
  1165. novalue mvc(n, src, dest)
  1166. uword n;
  1167. register char *src, *dest;
  1168.    {
  1169.    register char *srcend, *destend;        /* end of data areas */
  1170.    word copy_size;                  /* of size copy_size */
  1171.    word left_over;         /* size of last chunk < copy_size */
  1172.  
  1173.    if (n == 0)
  1174.       return;
  1175.  
  1176.    srcend  = src + n;    /* point at byte after src data */
  1177.    destend = dest + n;   /* point at byte after dest area */
  1178.  
  1179.    if ((destend <= src) || (srcend <= dest))  /* not overlapping */
  1180.       memcopy(dest,src,n);
  1181.  
  1182.    else {                     /* overlapping data areas */
  1183.       if (dest < src) {
  1184.          /*
  1185.           * The move is from higher memory to lower memory.
  1186.           */
  1187.          copy_size = DiffPtrs(src,dest);
  1188.  
  1189.          /* now loop round copying copy_size chunks of data */
  1190.  
  1191.          do {
  1192.             memcopy(dest,src,copy_size);
  1193.             dest = src;
  1194.             src = src + copy_size;
  1195.             }
  1196.          while (DiffPtrs(srcend,src) > copy_size);
  1197.  
  1198.          left_over = DiffPtrs(srcend,src);
  1199.  
  1200.          /* copy final fragment of data - if there is one */
  1201.  
  1202.          if (left_over > 0)
  1203.             memcopy(dest,src,left_over);
  1204.          }
  1205.  
  1206.       else if (dest > src) {
  1207.          /*
  1208.           * The move is from lower memory to higher memory.
  1209.           */
  1210.          copy_size = DiffPtrs(destend,srcend);
  1211.  
  1212.          /* now loop round copying copy_size chunks of data */
  1213.  
  1214.          do {
  1215.             destend = srcend;
  1216.             srcend  = srcend - copy_size;
  1217.             memcopy(destend,srcend,copy_size);
  1218.             }
  1219.          while (DiffPtrs(srcend,src) > copy_size);
  1220.  
  1221.          left_over = DiffPtrs(srcend,src);
  1222.  
  1223.          /* copy intial fragment of data - if there is one */
  1224.  
  1225.          if (left_over > 0) memcopy(dest,src,left_over);
  1226.          }
  1227.  
  1228.       } /* end of overlapping data area code */
  1229.  
  1230.    /*
  1231.     *  Note that src == dest implies no action
  1232.     */
  1233.    }
  1234.  
  1235.  
  1236. /*
  1237.  * sweep - sweep the chain of tended descriptors for a co-expression
  1238.  *  marking the descriptors.
  1239.  */
  1240. novalue sweep(ce)
  1241. struct b_coexpr *ce;
  1242.    {
  1243.    register struct tend_desc *tp;
  1244.    register int i;
  1245.  
  1246.    for (tp = ce->es_tend; tp != NULL; tp = tp->previous) {
  1247.       for (i = 0; i < tp->num; ++i) {
  1248.          if (Qual(tp->d[i]))
  1249.             postqual(&tp->d[i]);
  1250.          else if (Pointer(tp->d[i])) {
  1251.             if(BlkLoc(tp->d[i]) != NULL)
  1252.                markblock(&tp->d[i]);
  1253.         }
  1254.          }
  1255.       }
  1256. #if !COMPILER
  1257.    sweep_stk(ce);
  1258. #endif                    /* !COMPILER */
  1259.    }
  1260.  
  1261. #if !COMPILER
  1262.  
  1263. /*
  1264.  * sweep_stk - sweep the stack, marking all descriptors there.  Method
  1265.  *  is to start at a known point, specifically, the frame that the
  1266.  *  fp points to, and then trace back along the stack looking for
  1267.  *  descriptors and local variables, marking them when they are found.
  1268.  *  The sp starts at the first frame, and then is moved down through
  1269.  *  the stack.  Procedure, generator, and expression frames are
  1270.  *  recognized when the sp is a certain distance from the fp, gfp,
  1271.  *  and efp respectively.
  1272.  *
  1273.  * Sweeping problems can be manifested in a variety of ways due to
  1274.  *  the "if it can't be identified it's a descriptor" methodology.
  1275.  */
  1276. novalue sweep_stk(ce)
  1277. struct b_coexpr *ce;
  1278.    {
  1279.    register word *s_sp;
  1280.    register struct pf_marker *fp;
  1281.    register struct gf_marker *s_gfp;
  1282.    register struct ef_marker *s_efp;
  1283.    word nargs, type, gsize;
  1284.  
  1285.    fp = ce->es_pfp;
  1286.    s_gfp = ce->es_gfp;
  1287.    if (s_gfp != 0) {
  1288.       type = s_gfp->gf_gentype;
  1289.       if (type == G_Psusp)
  1290.          gsize = Wsizeof(*s_gfp);
  1291.       else
  1292.          gsize = Wsizeof(struct gf_smallmarker);
  1293.       }
  1294.    s_efp = ce->es_efp;
  1295.    s_sp =  ce->es_sp;
  1296.    nargs = 0;                           /* Nargs counter is 0 initially. */
  1297.  
  1298.    while ((fp != 0 || nargs)) {         /* Keep going until current fp is
  1299.                                             0 and no arguments are left. */
  1300.       if (s_sp == (word *)fp + Vwsizeof(*pfp) - 1) {
  1301.                                         /* sp has reached the upper
  1302.                                             boundary of a procedure frame,
  1303.                                             process the frame. */
  1304.          s_efp = fp->pf_efp;            /* Get saved efp out of frame */
  1305.          s_gfp = fp->pf_gfp;            /* Get save gfp */
  1306.          if (s_gfp != 0) {
  1307.             type = s_gfp->gf_gentype;
  1308.             if (type == G_Psusp)
  1309.                gsize = Wsizeof(*s_gfp);
  1310.             else
  1311.                gsize = Wsizeof(struct gf_smallmarker);
  1312.             }
  1313.          s_sp = (word *)fp - 1;         /* First argument descriptor is
  1314.                                             first word above proc frame */
  1315.          nargs = fp->pf_nargs;
  1316.          fp = fp->pf_pfp;
  1317.          }
  1318.       else if (s_gfp != NULL && s_sp == (word *)s_gfp + gsize - 1) {
  1319.                                         /* The sp has reached the lower end
  1320.                                             of a generator frame, process
  1321.                                             the frame.*/
  1322.          if (type == G_Psusp)
  1323.             fp = s_gfp->gf_pfp;
  1324.          s_sp = (word *)s_gfp - 1;
  1325.          s_efp = s_gfp->gf_efp;
  1326.          s_gfp = s_gfp->gf_gfp;
  1327.          if (s_gfp != 0) {
  1328.             type = s_gfp->gf_gentype;
  1329.             if (type == G_Psusp)
  1330.                gsize = Wsizeof(*s_gfp);
  1331.             else
  1332.                gsize = Wsizeof(struct gf_smallmarker);
  1333.             }
  1334.          nargs = 1;
  1335.          }
  1336.       else if (s_sp == (word *)s_efp + Wsizeof(*s_efp) - 1) {
  1337.                                             /* The sp has reached the upper
  1338.                                                 end of an expression frame,
  1339.                                                 process the frame. */
  1340.          s_gfp = s_efp->ef_gfp;         /* Restore gfp, */
  1341.          if (s_gfp != 0) {
  1342.             type = s_gfp->gf_gentype;
  1343.             if (type == G_Psusp)
  1344.                gsize = Wsizeof(*s_gfp);
  1345.             else
  1346.                gsize = Wsizeof(struct gf_smallmarker);
  1347.             }
  1348.          s_efp = s_efp->ef_efp;         /*  and efp from frame. */
  1349.          s_sp -= Wsizeof(*s_efp);       /* Move past expression frame marker. */
  1350.          }
  1351.       else {                            /* Assume the sp is pointing at a
  1352.                                             descriptor. */
  1353.          if (Qual(*((dptr)(&s_sp[-1]))))
  1354.             postqual((dptr)&s_sp[-1]);
  1355.          else if (Pointer(*((dptr)(&s_sp[-1])))) {
  1356.             markblock((dptr)&s_sp[-1]);
  1357.         }
  1358.          s_sp -= 2;                     /* Move past descriptor. */
  1359.          if (nargs)                     /* Decrement argument count if in an*/
  1360.             nargs--;                    /*  argument list. */
  1361.          }
  1362.       }
  1363.    }
  1364. #endif                    /* !COMPILER */
  1365.  
  1366. #ifdef DeBugIconx
  1367. /*
  1368.  * descr - dump a descriptor.  Used only for debugging.
  1369.  */
  1370.  
  1371. novalue descr(dp)
  1372. dptr dp;
  1373.    {
  1374.    int i;
  1375.  
  1376.    fprintf(stderr,"%08lx: ",(long)dp);
  1377.    if (Qual(*dp))
  1378.       fprintf(stderr,"%15s","qualifier");
  1379.  
  1380.    else if (Var(*dp))
  1381.       fprintf(stderr,"%15s","variable");
  1382.    else {
  1383.       i =  Type(*dp);
  1384.       switch (i) {
  1385.          case T_Null:
  1386.             fprintf(stderr,"%15s","null");
  1387.             break;
  1388.          case T_Integer:
  1389.             fprintf(stderr,"%15s","integer");
  1390.             break;
  1391.          default:
  1392.             fprintf(stderr,"%15s",blkname[i]);
  1393.          }
  1394.       }
  1395.    fprintf(stderr," %08lx %08lx\n",(long)dp->dword,(long)IntVal(*dp));
  1396.    }
  1397.  
  1398. /*
  1399.  * blkdump - dump the allocated block region.  Used only for debugging.
  1400.  */
  1401.  
  1402. novalue blkdump()
  1403.    {
  1404.    register char *blk;
  1405.    register word type, size, fdesc;
  1406.    register dptr ndesc;
  1407.  
  1408.    fprintf(stderr,
  1409.       "\nDump of allocated block region.  base:%08lx free:%08lx max:%08lx\n",
  1410.          (long)blkbase,(long)blkfree,(long)blkend);
  1411.    fprintf(stderr,"  loc     type              size  contents\n");
  1412.  
  1413.    for (blk = blkbase; blk < blkfree; blk += BlkSize(blk)) {
  1414.       type = BlkType(blk);
  1415.       size = BlkSize(blk);
  1416.       fprintf(stderr," %08lx   %15s   %4ld\n",(long)blk,blkname[type],
  1417.          (long)size);
  1418.       if ((fdesc = firstd[type]) > 0)
  1419.          for (ndesc = (dptr)(blk + fdesc);
  1420.                ndesc < (dptr)(blk + size); ndesc++) {
  1421.             fprintf(stderr,"                                 ");
  1422.             descr(ndesc);
  1423.             }
  1424.       fprintf(stderr,"\n");
  1425.       }
  1426.    fprintf(stderr,"end of block region.\n");
  1427.    }
  1428. #endif                                  /* DeBugIconx */
  1429.